home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / sml_nj / 93src.lha / src / parse / ml.grm < prev   
Encoding:
Text File  |  1993-01-27  |  22.7 KB  |  718 lines
  1. (* Copyright 1989,1992 by AT&T Bell Laboratories *)
  2. open Ast ErrorMsg Symbol FastSymbol AstUtil Fixity 
  3.  
  4. type env = parseEnv
  5. type raw_symbol = FastSymbol.raw_symbol
  6.  
  7. fun markexp (e as MarkExp _, _, _) = e
  8.   | markexp(e,a,b) = MarkExp(e,a,b)
  9. fun markdec((d as MarkDec _, e), _,_) = (d,e)
  10.   | markdec((d,e),a,b) = (MarkDec(d,a,b),e)
  11.  
  12. fun identity x = x
  13.  
  14. fun sequence (do1,do2) env =
  15.   let val r1 = do1 env
  16.     val r2 = do2 env
  17.   in r1 @ r2 end
  18.  
  19. fun seqdec dcl env = let val (d,e) = dcl env in ([d],e) end
  20.  
  21. val asteriskHash = StrgHash.hashString "*"
  22. val asteriskString = "*"
  23. val equalHash = StrgHash.hashString "="
  24. val equalString = "="
  25. val bogusHash = StrgHash.hashString "BOGUS"
  26. val bogusString = "BOGUS"
  27. val quotedBogusHash = StrgHash.hashString "'BOGUS"
  28. val quotedBogusString = "'BOGUS"
  29. val quotedBogusHash = StrgHash.hashString "'BOGUS"
  30. val quotedBogusString = "'BOGUS"
  31.  
  32. %%
  33. %term
  34.     EOF | SEMICOLON
  35.   | ID of FastSymbol.raw_symbol | TYVAR of FastSymbol.raw_symbol
  36.   | INT of int | INT0 of int | REAL of string | STRING of string 
  37.   | ABSTRACTION | ABSTYPE | AND
  38.   | ARROW | AS | BAR | CASE | DATATYPE | DOTDOTDOT | ELSE | END | EQUAL
  39.   | EQTYPE | EXCEPTION | DO | DOT | DARROW | FN | FUN | FUNCTOR | HANDLE | HASH
  40.   | IF | IN | INCLUDE | INFIX | INFIXR | LET | LOCAL | NONFIX | OF | OP
  41.   | OPEN | OVERLOAD | RAISE | REC | SHARING | SIG | SIGNATURE | STRUCT
  42.   | STRUCTURE | THEN | TYPE | VAL | WHILE | WILD | WITH | WITHTYPE | ASTERISK
  43.   | COLON | COMMA | LBRACE | LBRACKET | LPAREN | RBRACE | RBRACKET | RPAREN
  44.   | ORELSE | ANDALSO | FUNSIG | VECTORSTART
  45.   | BEGINQ | ENDQ of string | OBJL of string | AQID of FastSymbol.raw_symbol
  46.  
  47. %nonterm  ident of FastSymbol.raw_symbol
  48.     | id of FastSymbol.raw_symbol
  49.     | int of int
  50.     | op_op of unit -> unit
  51.     | opid of env -> symbol 
  52.     | qid of (FastSymbol.raw_symbol ->symbol) -> symbol list 
  53.     | selector of symbol
  54.     | tycon of symbol list
  55.     | tlabel of (symbol * ty)
  56.     | tlabels  of (symbol * ty) list 
  57.     | ty' of ty
  58.     | tuple_ty of ty list
  59.     | ty of ty
  60.     | ty0_pc of ty list
  61.     | match of env -> rule list
  62.     | rule of env -> rule
  63.     | elabel of env -> (symbol * exp)
  64.     | elabels of env -> (symbol * exp) list
  65.     | exp_ps of env -> exp list
  66.     | exp of env -> exp 
  67.     | app_exp of env -> exp precStack
  68.     | aexp of env -> exp
  69.     | exp_list of env -> exp list
  70.     | exp_2c  of env -> exp list
  71.     | quote of env -> exp list
  72.     | ot_list of env -> exp list
  73.     | pat of env -> pat
  74.     | pat' of env -> pat 
  75.     | pat'' of env -> pat
  76.     | apat of env -> (pat * fixity * complainer)
  77.     | apat' of env -> (pat * fixity * complainer)
  78.     | apat'' of env -> pat
  79.     | plabel of env -> (symbol * pat)
  80.     | plabels of env -> ((symbol * pat) list * bool)
  81.     | pat_2c of env -> pat list
  82.     | pat_list of env -> pat list
  83.     | vb of env -> vb list
  84.     | constraint of ty option
  85.     | rvb of env -> rvb list
  86.     | fb' of env -> rawclause list
  87.     | fb of env -> (rawclause list * linenum * linenum) list
  88.     | apats of env -> (pat * fixity * complainer) list
  89.     | clause' of env -> (symbol * pat list)
  90.     | clause of env -> rawclause
  91.     | tb of tb list
  92.     | tyvars of tyvar list
  93.     | tyvar_pc of tyvar list
  94.     | db of db list
  95.     | constrs of (symbol * ty option) list
  96.     | constr of symbol * ty option
  97.     | eb of eb list
  98.     | qid_p of Symbol.symbol list list
  99.     | fixity of unit -> fixity
  100.     | ldec of env -> dec * (env -> env)
  101.     | exp_pa of env ->  exp list
  102.     | ldecs of env -> dec * (env -> env)
  103.     | ops of symbol list
  104.     | spec_s of spec list
  105.     | spec of spec list
  106.     | idents of spec list
  107.     | strspec of (symbol * sigexp) list
  108.     | fctspec of (symbol * fsigexp) list
  109.     | tyspec of  (symbol * tyvar list) list
  110.     | valspec of (symbol * ty) list
  111.     | exnspec of (symbol * ty option) list
  112.     | sharespec of spec list
  113.     | patheqn of (FastSymbol.raw_symbol ->symbol) -> symbol list list
  114.     | sign of sigexp
  115.     | sigconstraint_op of sigexp option
  116.     | fsigconstraint_op of fsigexp option
  117.     | sigb of sigb list
  118.     | fsigb of fsigb list
  119.     | fsig of  fsigexp
  120.     | str of env -> strexp
  121.     | arg_fct of env -> (strexp * bool) list
  122.     | sdecs of env -> dec * (env -> env)
  123.      | sdecs' of env -> dec * (env -> env)
  124.     | sdec of env -> dec * (env -> env)
  125.     | strb of env -> strb list
  126.     | fparam of symbol option * sigexp
  127.     | fparamList of (symbol option * sigexp) list
  128.     | fctb of env -> fctb list
  129.     | fct_exp of env * fsigexp option -> fctexp
  130.     | interdec of env -> dec * env
  131.  
  132. %pos int
  133. %arg (error) : pos * pos -> ErrorMsg.complainer
  134. %pure
  135. %start interdec
  136. %eop EOF SEMICOLON
  137. %noshift EOF
  138.  
  139. %nonassoc WITHTYPE
  140. %right AND
  141. %right ARROW
  142. %right AS
  143. %right DARROW 
  144. %left DO
  145. %left ELSE
  146. %left RAISE
  147. %right HANDLE
  148. %left ORELSE
  149. %left ANDALSO
  150. %left COLON
  151.  
  152. %name ML
  153.  
  154. %keyword ABSTRACTION ABSTYPE AND AS CASE DATATYPE DOTDOTDOT ELSE END 
  155.   EQTYPE EXCEPTION  DO  DARROW  FN  FUN  FUNCTOR  HANDLE
  156.   IF IN INCLUDE  INFIX  INFIXR  LET  LOCAL  NONFIX  OF  OP
  157.   OPEN OVERLOAD  RAISE  REC  SHARING  SIG  SIGNATURE  STRUCT
  158.   STRUCTURE THEN TYPE VAL WHILE WITH WITHTYPE
  159.   ORELSE ANDALSO 
  160.  
  161. %subst EQUAL for DARROW | DARROW for EQUAL | ANDALSO for AND | OF for COLON
  162.      | COMMA for SEMICOLON | SEMICOLON for COMMA
  163. %prefer VAL THEN ELSE LPAREN
  164.  
  165. %value ID (rawSymbol(bogusHash,bogusString))
  166. %value TYVAR (rawSymbol(quotedBogusHash,quotedBogusString))
  167. %value INT (1)
  168. %value INT0 (0)
  169. %value REAL ("0.0")
  170. %value STRING ("")
  171.  
  172. %%
  173.  
  174. int    : INT        (INT)
  175.     | INT0        (INT0)
  176.  
  177. id    : ID        (ID)
  178.     | ASTERISK    (rawSymbol (asteriskHash,asteriskString))
  179.  
  180. ident    : ID         (ID)
  181.     | ASTERISK    (rawSymbol (asteriskHash,asteriskString))
  182.     | EQUAL        (rawSymbol (equalHash,equalString))
  183.  
  184. op_op    : OP        (fn()=> error (OPleft,OPright) WARN "unnecessary `op'"
  185.                       nullErrorBody)
  186.     |         (fn()=>())
  187.  
  188. opid    : id        (fn env => let val (v,f) = var'n'fix id
  189.                    in case lookFIX (env,f) of NONfix => ()
  190.                       | _ => error (idleft,idright) COMPLAIN
  191.                         "nonfix identifier required"
  192.                         nullErrorBody;
  193.                       v
  194.                    end)
  195.     | OP ident    (fn _ => varSymbol ident)
  196.  
  197. qid    : ID DOT qid    (fn kind => strSymbol ID :: qid kind)
  198.     | ident        (fn kind => [kind ident])
  199.  
  200. selector: id        (labSymbol id)
  201.     | INT        (Symbol.labSymbol(makestring INT))
  202.  
  203. tycon   : ID DOT tycon        (strSymbol ID :: tycon)
  204.     | ID            ([tycSymbol ID])
  205.  
  206. tlabel    : selector COLON ty    (selector, ty )
  207.  
  208. tlabels : tlabel COMMA tlabels    (tlabel :: tlabels)
  209.     | tlabel        ([tlabel])
  210.  
  211. ty'    : TYVAR        (MarkTy (VarTy(Tyv(tyvSymbol TYVAR)),
  212.                  TYVARleft,TYVARright))
  213.     | LBRACE tlabels
  214.          RBRACE (MarkTy(RecordTy tlabels,LBRACEleft,RBRACEright))
  215.     | LBRACE RBRACE    (RecordTy [])
  216.     | LPAREN ty0_pc RPAREN tycon  
  217.             (MarkTy(ConTy(tycon,ty0_pc),tyconleft,tyconright))
  218.     | LPAREN ty RPAREN    (ty)
  219.     | ty' tycon    (MarkTy(ConTy(tycon,[ty']),tyconleft,tyconright))
  220.     | tycon        (MarkTy(ConTy(tycon,[]),tyconleft,tyconright))
  221.  
  222. tuple_ty : ty' ASTERISK tuple_ty     (ty' :: tuple_ty)
  223.      | ty' ASTERISK ty'         ([ty'1,ty'2])
  224.  
  225. ty    : tuple_ty    (TupleTy(tuple_ty))
  226.     | ty ARROW ty    (ConTy([arrowTycon], [ty1,ty2]))
  227.     | ty'         (ty')
  228.     
  229. ty0_pc    : ty COMMA ty        ([ty1,ty2])
  230.     | ty COMMA ty0_pc     (ty :: ty0_pc)
  231.  
  232. match    : rule            (fn env => [rule env])
  233.     | rule BAR match    (fn env => rule env :: match env)
  234.  
  235. rule    : pat DARROW exp    
  236.         (fn env => Rule{pat=pat env,
  237.                 exp=markexp(exp env,expleft,expright)})
  238.  
  239.         (*     EXPRESSIONS    *)
  240.  
  241. elabel    : selector EQUAL exp    (fn env => (selector,exp env))
  242.  
  243. elabels : elabel COMMA elabels    (fn env => (elabel env :: elabels env))
  244.     | elabel    (fn env => [elabel env])
  245.  
  246. exp_ps    : exp        (fn env => [exp env])
  247.     | exp SEMICOLON 
  248.         exp_ps    (fn env => exp env :: exp_ps env)
  249.  
  250. exp    : exp HANDLE 
  251.         match    (fn env => HandleExp{expr=exp env,rules=match env})
  252.  
  253.     | exp ORELSE exp
  254.             (fn env => OrelseExp
  255.                       (markexp(exp1 env,exp1left,exp1right),
  256.                        markexp(exp2 env,exp2left,exp2right)))
  257.     | exp ANDALSO exp (fn env=> AndalsoExp
  258.                       (markexp(exp1 env,exp1left,exp1right),
  259.                        markexp(exp2 env,exp2left,exp2right)))
  260.     | exp COLON ty    (fn env => ConstraintExp{expr=exp env,constraint=ty})
  261.     | app_exp    (fn env => 
  262.                exp_finish(app_exp env,
  263.                       error(app_expright,app_expright)))
  264.  
  265.     | FN match    (fn env=> markexp(FnExp(match env),FNleft,matchright))
  266.     | CASE exp OF match
  267.         (fn env=>markexp(CaseExp{expr=exp env,rules=match env},
  268.                      CASEleft,matchright))
  269.     | WHILE exp DO exp    
  270.         (fn env=> WhileExp{test=markexp(exp1 env,exp1left, exp1right),
  271.                    expr=markexp(exp2 env,exp2left, exp2right)})
  272.     | IF exp THEN exp ELSE exp     
  273.         (fn env=>IfExp{test=exp1 env,
  274.                    thenCase=markexp(exp2 env,exp2left,exp2right),
  275.                    elseCase=markexp(exp3 env,exp3left,exp3right)})
  276.     | RAISE exp    
  277.         (fn env => markexp(markexp(RaiseExp(exp env),expleft,expright),
  278.                    RAISEleft,expright))
  279.  
  280. app_exp    : aexp    (fn env => exp_start(markexp(aexp env,aexpleft,aexpright),
  281.                      NONfix, error (aexpleft,aexpright)))
  282.         | ident    (fn env => let val e = error(identleft,identright)
  283.                    val (v,f) = var'n'fix ident
  284.                in exp_start(markexp(VarExp [v],
  285.                         identleft,identright),
  286.                     lookFIX (env,f), e)
  287.                end)
  288.     | app_exp aexp    (fn env => exp_parse(app_exp env, 
  289.                     markexp(aexp env, aexpleft,aexpright),
  290.                     NONfix,
  291.                     error (aexpleft,aexpright)))
  292.     | app_exp ident    (fn env => 
  293.                let val e = error(identleft,identright)
  294.                    val (v,f) = var'n'fix ident
  295.                in exp_parse(app_exp env, 
  296.                     markexp(VarExp [v], 
  297.                         identleft,identright),
  298.                     lookFIX(env,f), e)
  299.                end)
  300.  
  301. aexp    : OP ident        (fn env => VarExp [varSymbol ident])
  302.     | ID DOT qid        (fn env => VarExp (strSymbol ID
  303.                        :: qid varSymbol))
  304.     | int            (fn env => IntExp int)
  305.     | REAL            (fn env => RealExp REAL)
  306.     | STRING        (fn env => StringExp STRING)
  307.     | HASH selector        (fn env => SelectorExp selector)
  308.     | LBRACE elabels RBRACE    
  309.         (fn env => markexp(RecordExp(elabels env),
  310.                    LBRACEleft,RBRACEright))
  311.     | LBRACE RBRACE        (fn env => RecordExp nil)
  312.     | LPAREN RPAREN        (fn env => unitExp)
  313.     | LPAREN exp_ps RPAREN    (fn env => SeqExp(exp_ps env))
  314.     | LPAREN exp_2c RPAREN    (fn env => TupleExp(exp_2c env))
  315.     | LBRACKET exp_list RBRACKET    
  316.                 (fn env => ListExp(exp_list env))
  317.     | LBRACKET RBRACKET    (fn env => nilExp)
  318.         | VECTORSTART exp_list RBRACKET
  319.                 (fn env => VectorExp(exp_list env))      
  320.         | VECTORSTART RBRACKET
  321.                 (fn env => VectorExp nil) 
  322.     | LET ldecs IN exp_ps END    
  323.                 (fn env => 
  324.                     let val (d,f) = 
  325.                     markdec(ldecs env,ldecsleft,ldecsright)
  326.                         val e = exp_ps (f env)
  327.                     in markexp
  328.                      (LetExp{dec=d,expr=SeqExp e},
  329.                       LETleft,ENDright)
  330.                     end)
  331.         | AQID                  (fn env => VarExp([varSymbol AQID]))
  332.         | quote                 (fn env => ListExp (quote env))
  333.  
  334. quote   : BEGINQ ENDQ           (fn env => [QuoteExp ENDQ])
  335.         | BEGINQ ot_list ENDQ   (fn env => (ot_list env @ [QuoteExp ENDQ]))
  336.  
  337. ot_list : OBJL aexp             (fn env => 
  338.                   [QuoteExp OBJL,AntiquoteExp (aexp env)])
  339.         | OBJL aexp ot_list     (fn env => (QuoteExp OBJL ::
  340.                                             AntiquoteExp (aexp env) ::
  341.                                             ot_list env))
  342.  
  343. exp_2c    : exp COMMA exp_2c    (fn env => exp env :: exp_2c env)
  344.     | exp COMMA exp        (fn env => [exp1 env, exp2 env])
  345.  
  346. exp_list : exp            (fn env=> [exp env])
  347.      | exp COMMA exp_list    (fn env=> exp env :: exp_list env)
  348.  
  349. pat    : pat'            (pat')
  350.     | apat apats        (fn env => make_app_pat(apat env ::apats env))
  351.  
  352. pat'    : pat AS pat        (fn env => layered(pat1 env, pat2 env,
  353.                            error(pat1left,pat1right)))
  354.     | pat''         (pat'')
  355.  
  356. pat''    : apat apats COLON ty    (fn env => 
  357.                    ConstraintPat
  358.                      {pattern=
  359.                     make_app_pat(apat env ::apats env),
  360.                       constraint=ty})
  361.     | pat'' COLON ty    (fn env => ConstraintPat{pattern=pat'' env,
  362.                              constraint=ty})
  363.  
  364. apat    : apat'            (apat')
  365.     | LPAREN pat RPAREN    (fn env =>(pat env,NONfix,
  366.                        error(LPARENleft,RPARENright)))
  367.  
  368. apat'    : apat''        (fn env =>(apat'' env,NONfix,
  369.                        error(apat''left,apat''right)))
  370.     | id            (fn env  =>
  371.                  let val e = error(idleft,idright)
  372.                      val (v,f) = var'n'fix id
  373.                  in (VarPat [v], lookFIX(env,f), e) end)
  374.     | LPAREN RPAREN        (fn _ =>(unitPat,NONfix,
  375.                      error(LPARENleft,RPARENright)))
  376.     | LPAREN pat COMMA  pat_list RPAREN    
  377.         (fn env =>(TuplePat(pat env :: pat_list env),
  378.                NONfix,error(LPARENleft,RPARENright)))
  379.  
  380. apat''    : OP ident        (fn env => VarPat [varSymbol ident])
  381.     | ID DOT qid        
  382.         (fn env => VarPat (strSymbol ID :: qid varSymbol))
  383.     | int            (fn _ =>IntPat int)
  384.     | REAL            (fn _ =>RealPat REAL)
  385.     | STRING        (fn _ =>StringPat STRING)
  386.     | WILD            (fn _ =>WildPat)
  387.     | LBRACKET RBRACKET    (fn _ =>ListPat nil)
  388.     | LBRACKET pat_list 
  389.         RBRACKET    (fn env => ListPat(pat_list env))
  390.         | VECTORSTART RBRACKET  (fn _ => VectorPat nil)
  391.     | VECTORSTART pat_list 
  392.         RBRACKET    (fn env => VectorPat(pat_list env))
  393.     | LBRACE RBRACE        (fn _ => unitPat)
  394.     | LBRACE plabels RBRACE    
  395.             (fn env => let val (d,f) = plabels env 
  396.                        in MarkPat(RecordPat{def=d,flexibility=f},
  397.                   LBRACEleft,RBRACEright) end)
  398.  
  399. plabel    : selector EQUAL pat    (fn env => (selector,pat env))
  400.     | ID            (fn env => 
  401.                    (labSymbol ID, VarPat [varSymbol ID]))
  402.     | ID AS pat        (fn env => 
  403.                    (labSymbol ID, 
  404.                     LayeredPat{varPat=VarPat [varSymbol ID], 
  405.                                expPat=pat env}))
  406.     | ID COLON ty    
  407.         (fn env => (labSymbol ID,
  408.                 ConstraintPat{pattern=VarPat [varSymbol ID],
  409.                       constraint=ty}))
  410.     | ID COLON ty AS pat
  411.         (fn env => 
  412.            (labSymbol ID,
  413.             LayeredPat
  414.               {varPat=ConstraintPat{pattern=VarPat [varSymbol ID],
  415.                         constraint=ty},
  416.                expPat=pat env}))
  417.  
  418. plabels : plabel COMMA plabels    
  419.         (fn env =>let val (a,(b,fx))=(plabel env,plabels env)
  420.               in (a::b, fx) end)
  421.     | plabel    (fn env => ([plabel env],false))
  422.     | DOTDOTDOT    (fn _ => (nil, true))
  423.  
  424. pat_list: pat            (fn env => [pat env])
  425.     | pat COMMA pat_list    (fn env => pat env :: pat_list env)
  426.  
  427. vb    : vb AND vb    (fn env => vb1 env @ vb2 env)
  428.     | pat EQUAL exp    
  429.         (fn env => 
  430.            [MarkVb(Vb{exp=exp env, pat=pat env},patleft,expright)])
  431.  
  432. constraint :             (NONE)
  433.        | COLON ty         (SOME ty)
  434.  
  435. rvb    : opid constraint EQUAL FN match
  436.         (fn env =>[MarkRvb(Rvb{var=opid env,resultty=constraint,
  437.                    exp=FnExp(match env)},opidleft,matchright)])
  438.     | rvb AND rvb        (fn env => rvb1 env @ rvb2 env)
  439.  
  440. fb'    : clause        (fn env =>[clause env])
  441.     | clause BAR fb'    (fn env =>clause env :: fb' env)
  442.  
  443. fb    : fb'    
  444.     (fn env => [(checkFB(fb' env,error(fb'left,fb'right)),
  445.              fb'left,fb'right)])
  446.     | fb' AND fb    
  447.     (fn env => (checkFB(fb' env,error(fb'left,fb'right)),fb'left,fb'right)
  448.            :: fb env)
  449.  
  450. clause'    : LPAREN apat apats RPAREN apats
  451.         (fn env =>makecl(apat env :: apats1 env,apats2 env))
  452.     | LPAREN pat' RPAREN apats
  453.         (fn env => makecl([],(pat' env, NONfix,
  454.                     error(LPARENleft,RPARENright))
  455.                    :: apats env))
  456.     | apat' apats        (fn env => makecl([],apat' env :: apats env))
  457.  
  458. apats    :            (fn _ =>nil)
  459.     | apat apats        (fn env => apat env :: apats env) 
  460.  
  461. clause    : clause' constraint EQUAL exp    
  462.         (fn env => let val (id,pats) = clause' env
  463.                in {name=id,pats=pats,resultty=constraint,
  464.                    exp=fn env => markexp(exp env,expleft,expright),
  465.                    err=error(clause'left,clause'right)}
  466.                end)
  467.  
  468. tb    : tyvars ID EQUAL ty    ([MarkTb(
  469.                    Tb{tyvars=tyvars,tyc=tycSymbol ID,def=ty},
  470.                    tyleft,tyright)])
  471.     | tb AND tb        (tb1 @ tb2)
  472.  
  473. tyvars    : TYVAR            ([MarkTyv(Tyv(tyvSymbol TYVAR),
  474.                      TYVARleft,TYVARright)])
  475.     | LPAREN tyvar_pc RPAREN  (tyvar_pc)
  476.     |              (nil)
  477.  
  478. tyvar_pc: TYVAR    ([MarkTyv(Tyv(tyvSymbol TYVAR), TYVARleft,TYVARright)])
  479.     | TYVAR COMMA tyvar_pc
  480.         (MarkTyv(Tyv(tyvSymbol TYVAR),TYVARleft,TYVARright)
  481.          :: tyvar_pc)
  482.  
  483. db    : db AND db            (db1 @ db2)
  484.     | tyvars ident EQUAL constrs    (let val name = tycSymbol ident
  485.                      in [Db{tyc=name,tyvars=tyvars,
  486.                             def=constrs}] end)
  487.  
  488. constrs : constr        ([constr])
  489.     | constr BAR constrs    (constr :: constrs)
  490.  
  491. constr    : op_op ident        (op_op ();(varSymbol ident,NONE))
  492.     | op_op ident OF ty    (op_op ();(varSymbol ident, SOME ty))
  493.  
  494. eb    : op_op ident        
  495.         (op_op ();[EbGen{exn=(varSymbol ident),etype=NONE}])
  496.     | op_op ident OF ty    
  497.         (op_op ();[EbGen{exn=(varSymbol ident),etype=SOME ty}])
  498.     | op_op ident EQUAL qid    
  499.         (op_op ();[EbDef{exn=varSymbol ident,edef=qid varSymbol}])
  500.     | eb AND eb        (eb1 @ eb2)
  501.  
  502. qid_p    : qid            ([qid strSymbol])
  503.     | qid qid_p        (qid strSymbol :: qid_p)
  504.  
  505. fixity    : INFIX            (fn _ => infixleft 0)
  506.     | INFIX int        (fn _ => infixleft (checkFix(int,error(intleft,intright))))
  507.     | INFIXR        (fn _ => infixright 0)
  508.     | INFIXR int        (fn _ => infixright (checkFix(int,error(intleft,intright))))
  509.     | NONFIX        (fn _ => NONfix)
  510.  
  511. ldec    : VAL vb        (fn env => (ValDec (vb env),identity))
  512.     | VAL REC rvb        (fn env => (ValrecDec(rvb env),identity))
  513.     | FUN fb        (makeFUNdec(fb,error(FUNleft,fbright)))
  514.     | TYPE tb        (fn env => (TypeDec tb,identity))
  515.     | DATATYPE db        
  516.         (fn env => (DatatypeDec{datatycs=db,withtycs=[]},identity))
  517.      | DATATYPE db WITHTYPE tb
  518.         (fn env => (DatatypeDec{datatycs=db,withtycs=tb},identity))
  519.     | ABSTYPE db WITH ldecs END
  520.         (fn env => let val (d,f) = ldecs env
  521.                            in (AbstypeDec{abstycs=db,withtycs=[],
  522.                           body=d},f)
  523.                end)
  524.     | ABSTYPE db WITHTYPE tb WITH ldecs END  
  525.         (fn env => let val (d,f) = ldecs env
  526.                            in (AbstypeDec{abstycs=db,withtycs=tb,
  527.                           body=d},f)
  528.                end)
  529.     | EXCEPTION eb        (fn env => (ExceptionDec eb, identity))
  530.     | OPEN qid_p        (fn env => (OpenDec qid_p, identity))
  531.     | fixity ops        (makeFIXdec(fixity (), ops))
  532.     | OVERLOAD ident COLON ty AS exp_pa
  533.         (fn env => (OvldDec(varSymbol ident,ty,exp_pa env),identity))
  534.  
  535. exp_pa    : exp            (fn env => [exp env])
  536.     | exp AND exp_pa    (fn env => exp env :: exp_pa env)
  537.  
  538. ldecs    :         (fn env => (SeqDec nil,identity))
  539.     | ldec ldecs
  540.         (makeSEQdec 
  541.            (fn env => markdec(ldec env,ldecleft,ldecright), ldecs))
  542.     | SEMICOLON ldecs    (ldecs)
  543.     | LOCAL ldecs IN ldecs END ldecs    
  544.          (makeSEQdec
  545.             (fn env => 
  546.              markdec(makeLOCALdec
  547.                       (fn env => markdec(ldecs1 env,
  548.                              ldecs1left,ldecs1right),
  549.                    fn env => markdec(ldecs2 env,
  550.                                  ldecs2left,ldecs2right))
  551.                         env,
  552.                                    LOCALleft,ENDright),
  553.                  ldecs3))
  554.  
  555. ops    : ident            ([fixSymbol ident])
  556.     | ident ops         (fixSymbol ident :: ops)
  557.  
  558. spec_s    :             ([])
  559.     | spec spec_s        (spec @ spec_s)
  560.     | SEMICOLON spec_s    (spec_s)
  561.  
  562. spec    : STRUCTURE strspec    ([StrSpec strspec])
  563.         | FUNCTOR fctspec    ([FctSpec fctspec])
  564.     | DATATYPE db        ([DataSpec db])
  565.     | TYPE tyspec        ([TycSpec(tyspec,false)])
  566.     | EQTYPE tyspec        ([TycSpec(tyspec,true)])
  567.     | VAL valspec        ([ValSpec valspec])
  568.     | EXCEPTION exnspec    ([ExceSpec exnspec])
  569.     | fixity ops        ([FixSpec {fixity=fixity (),ops=ops}])
  570.     | SHARING sharespec    (sharespec)
  571.     | OPEN qid_p        ([OpenSpec qid_p])
  572.     | LOCAL spec_s IN spec_s END
  573.                 ([LocalSpec (spec_s1, spec_s2)])
  574.     | INCLUDE idents    (idents)
  575.  
  576. idents    : ident            ([IncludeSpec(FastSymbol.sigSymbol ident)])
  577.     | ident idents        (IncludeSpec(FastSymbol.sigSymbol ident)
  578.                  :: idents)
  579.  
  580. strspec    : strspec AND strspec    (strspec1 @ strspec2)
  581.     | ident COLON sign    ([(strSymbol ident,sign)])
  582.  
  583. fctspec    : fctspec AND fctspec    (fctspec1 @ fctspec2)
  584.     | ident fsig        ([(fctSymbol ident,fsig)])
  585.  
  586. tyspec    : tyspec AND tyspec    (tyspec1 @ tyspec2)
  587.     | tyvars ID        ([(tycSymbol ID,tyvars)])
  588.  
  589. valspec    : valspec AND valspec    (valspec1 @ valspec2)
  590.     | op_op ident COLON ty    
  591.         (op_op ();[(varSymbol ident,ty)])
  592.  
  593.  
  594. exnspec : exnspec AND exnspec    (exnspec1 @ exnspec2)
  595.     | ident            ([(varSymbol ident,NONE)])
  596.     | ident OF ty        ([(varSymbol ident,SOME ty)])
  597.  
  598. sharespec: sharespec AND sharespec    (sharespec1 @ sharespec2)
  599.      | TYPE patheqn    ([MarkSpec(ShatycSpec(patheqn tycSymbol),
  600.                    patheqnleft,patheqnright)])
  601.      | patheqn    ([MarkSpec (ShareSpec (patheqn strSymbol),
  602.                     patheqnleft,patheqnright)])
  603.     
  604. patheqn: qid EQUAL qid        (fn kind => [qid1 kind, qid2 kind])
  605.        | qid EQUAL patheqn    (fn kind => qid kind :: patheqn kind)
  606.  
  607. sign    : ID            (MarkSig(VarSig (sigSymbol ID),IDleft,IDright))
  608.     | SIG spec_s END    (MarkSig(SigSig spec_s,spec_sleft,spec_sright))
  609.  
  610.  
  611. sigconstraint_op :        (NONE)
  612.     | COLON sign        (SOME sign)
  613.  
  614. fsigconstraint_op :        (NONE)
  615.     | COLON ID        (SOME(VarFsig (fsigSymbol ID)))
  616.  
  617. sigb    : sigb AND sigb        (sigb1 @ sigb2)
  618.     | ident EQUAL sign    ([Sigb{name=sigSymbol ident,def=sign}])
  619.  
  620. fsigb    : fsigb AND fsigb    (fsigb1 @ fsigb2)
  621.     | ident fparamList EQUAL sign
  622.         ([Fsigb{name=fsigSymbol ident,
  623.             def=FsigFsig{param=fparamList,def=sign}}])
  624.  
  625. fsig    : COLON ID    (VarFsig (fsigSymbol ID))
  626.     | fparamList COLON sign
  627.             (FsigFsig{param=fparamList,def=sign})
  628.  
  629. str    : qid    (fn env => (MarkStr(VarStr(qid strSymbol),qidleft,qidright)))
  630.     | STRUCT sdecs END    
  631.         (fn env => let val (s,_) = sdecs env 
  632.                in MarkStr(StructStr s,STRUCTleft,ENDright) end)
  633.     | qid arg_fct
  634.         (fn env => MarkStr(AppStr(qid fctSymbol,arg_fct env),
  635.                    qidleft,arg_fctright))
  636.     | LET sdecs IN str END    
  637.         (fn env => MarkStr(makeLETstr(sdecs ,str) env,
  638.                    LETleft,ENDright))
  639.  
  640. arg_fct : LPAREN sdecs RPAREN arg_fct
  641.             (fn env => 
  642.                let val arg = MarkStr(StructStr (#1 (sdecs env)),
  643.                           sdecsleft,sdecsright)
  644.                in (arg,false) :: arg_fct env end)
  645.     | LPAREN str RPAREN arg_fct
  646.             (fn env => (str env,true) :: arg_fct env)
  647.     | LPAREN str RPAREN (fn env => [(str env,true)])
  648.     | LPAREN sdecs RPAREN 
  649.             (fn env => [(MarkStr(StructStr (#1 (sdecs env)),
  650.                         sdecsleft,sdecsright),
  651.                     false)])
  652.  
  653. sdecs    : sdec sdecs        
  654.         (makeSEQdec (fn env => markdec(sdec env,sdecleft,sdecright),
  655.                  sdecs))
  656.     | SEMICOLON sdecs    (sdecs)
  657.     |            (fn env => (SeqDec[],identity))
  658.  
  659. sdecs'    : sdec sdecs'        
  660.         (makeSEQdec (fn env => markdec(sdec env,sdecleft,sdecright),
  661.                  sdecs'))
  662.     | sdec    (fn env => markdec(sdec env,sdecleft,sdecright))
  663.  
  664. sdec    : STRUCTURE strb    (fn env => (StrDec (strb env),identity))
  665.     | ABSTRACTION strb    (fn env => (AbsDec (strb env),identity))
  666.     | SIGNATURE sigb    (fn env => (SigDec sigb,identity))
  667.     | FUNSIG fsigb        (fn env => (FsigDec fsigb,identity))
  668.     | FUNCTOR fctb        (fn env => (FctDec (fctb env),identity))
  669.     | LOCAL sdecs IN sdecs END
  670.         (makeLOCALdec
  671.            (fn env => markdec(sdecs1 env,sdecs1left,sdecs1right),
  672.             fn env => markdec(sdecs2 env,sdecs2left,sdecs2right)))
  673.     | ldec
  674.         (fn env => markdec(ldec env,ldecleft,ldecright))
  675.  
  676. strb    : ident sigconstraint_op EQUAL str
  677.     (fn env =>
  678.        let val d = Strb{name = strSymbol ident,def = str env, 
  679.                 constraint=sigconstraint_op}
  680.        in [MarkStrb(d,identleft,strright)] end)
  681.     | strb AND strb        (fn env => strb1 env @ strb2 env)
  682.  
  683. fparam    : ID COLON sign    (SOME(strSymbol ID),sign)
  684.     | spec_s    (NONE,MarkSig(SigSig spec_s, spec_sleft,spec_sright))
  685.  
  686. fparamList
  687.     : LPAREN fparam    RPAREN            ([fparam])
  688.     | LPAREN fparam RPAREN fparamList    (fparam :: fparamList)
  689.  
  690. fctb    : ident fparamList sigconstraint_op EQUAL str
  691.         (fn env => [MarkFctb(Fctb {name = fctSymbol ident,
  692.                        def = FctFct{params=fparamList,
  693.                             body=str env,
  694.                               constraint=
  695.                               sigconstraint_op}},
  696.                identleft,strright)])
  697.     | ident fsigconstraint_op EQUAL fct_exp
  698.           (fn env =>
  699.             [MarkFctb(Fctb {name=fctSymbol ident,
  700.                     def=fct_exp (env,fsigconstraint_op)},
  701.                   identleft,fct_expright)])
  702.     | fctb AND fctb        (sequence (fctb1,fctb2))
  703.  
  704. fct_exp: qid    (fn (env,constraint) => VarFct(qid fctSymbol,constraint))
  705.        | qid arg_fct
  706.           (fn (env,constraint) =>
  707.             MarkFct(AppFct(qid fctSymbol,arg_fct env,constraint),
  708.                 qidleft,arg_fctright))
  709.        | LET sdecs IN fct_exp END    
  710.         (fn (env,constraint) =>
  711.            MarkFct(makeLETfct(sdecs, fct_exp) env constraint,
  712.            LETleft,ENDright))
  713.  
  714. interdec: sdecs'(fn env=>
  715.            let val (ast,f) = markdec(sdecs' env,sdecs'left,sdecs'right)
  716.            in (ast,f Env.empty) end)
  717.     | exp    (fn env => markdec(toplevelexp(env,exp),expleft,expright))
  718.